home *** CD-ROM | disk | FTP | other *** search
/ Cream of the Crop 26 / Cream of the Crop 26.iso / os2 / octa209s.zip / octave-2.09 / libcruft / dassl / xerprn.f < prev    next >
Text File  |  1996-07-19  |  9KB  |  226 lines
  1. C*DECK XERPRN
  2.       SUBROUTINE XERPRN (PREFIX, NPREF, MESSG, NWRAP)
  3. C***BEGIN PROLOGUE  XERPRN
  4. C***SUBSIDIARY
  5. C***PURPOSE  This routine is called by XERMSG to print error messages
  6. C***LIBRARY   SLATEC
  7. C***CATEGORY  R3C
  8. C***TYPE      ALL
  9. C***KEYWORDS  ERROR MESSAGES, PRINTING, XERROR
  10. C***AUTHOR  FONG, KIRBY, (NMFECC AT LLNL)
  11. C***DESCRIPTION
  12. C
  13. C This routine sends one or more lines to each of the (up to five)
  14. C logical units to which error messages are to be sent.  This routine
  15. C is called several times by XERMSG, sometimes with a single line to
  16. C print and sometimes with a (potentially very long) message that may
  17. C wrap around into multiple lines.
  18. C
  19. C PREFIX  Input argument of type CHARACTER.  This argument contains
  20. C         characters to be put at the beginning of each line before
  21. C         the body of the message.  No more than 16 characters of
  22. C         PREFIX will be used.
  23. C
  24. C NPREF   Input argument of type INTEGER.  This argument is the number
  25. C         of characters to use from PREFIX.  If it is negative, the
  26. C         intrinsic function LEN is used to determine its length.  If
  27. C         it is zero, PREFIX is not used.  If it exceeds 16 or if
  28. C         LEN(PREFIX) exceeds 16, only the first 16 characters will be
  29. C         used.  If NPREF is positive and the length of PREFIX is less
  30. C         than NPREF, a copy of PREFIX extended with blanks to length
  31. C         NPREF will be used.
  32. C
  33. C MESSG   Input argument of type CHARACTER.  This is the text of a
  34. C         message to be printed.  If it is a long message, it will be
  35. C         broken into pieces for printing on multiple lines.  Each line
  36. C         will start with the appropriate prefix and be followed by a
  37. C         piece of the message.  NWRAP is the number of characters per
  38. C         piece; that is, after each NWRAP characters, we break and
  39. C         start a new line.  In addition the characters '$$' embedded
  40. C         in MESSG are a sentinel for a new line.  The counting of
  41. C         characters up to NWRAP starts over for each new line.  The
  42. C         value of NWRAP typically used by XERMSG is 72 since many
  43. C         older error messages in the SLATEC Library are laid out to
  44. C         rely on wrap-around every 72 characters.
  45. C
  46. C NWRAP   Input argument of type INTEGER.  This gives the maximum size
  47. C         piece into which to break MESSG for printing on multiple
  48. C         lines.  An embedded '$$' ends a line, and the count restarts
  49. C         at the following character.  If a line break does not occur
  50. C         on a blank (it would split a word) that word is moved to the
  51. C         next line.  Values of NWRAP less than 16 will be treated as
  52. C         16.  Values of NWRAP greater than 132 will be treated as 132.
  53. C         The actual line length will be NPREF + NWRAP after NPREF has
  54. C         been adjusted to fall between 0 and 16 and NWRAP has been
  55. C         adjusted to fall between 16 and 132.
  56. C
  57. C***REFERENCES  (NONE)
  58. C***ROUTINES CALLED  I1MACH, XGETUA
  59. C***REVISION HISTORY  (YYMMDD)
  60. C   880621  DATE WRITTEN
  61. C   880708  REVISED AFTER THE SLATEC CML SUBCOMMITTEE MEETING OF
  62. C           JUNE 29 AND 30 TO CHANGE THE NAME TO XERPRN AND TO REWORK
  63. C           THE HANDLING OF THE NEW LINE SENTINEL TO BEHAVE LIKE THE
  64. C           SLASH CHARACTER IN FORMAT STATEMENTS.
  65. C   890706  REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMMENS TO
  66. C           STREAMLINE THE CODING AND FIX A BUG THAT CAUSED EXTRA BLANK
  67. C           LINES TO BE PRINTED.
  68. C   890721  REVISED TO ADD A NEW FEATURE.  A NEGATIVE VALUE OF NPREF
  69. C           CAUSES LEN(PREFIX) TO BE USED AS THE LENGTH.
  70. C   891013  REVISED TO CORRECT ERROR IN CALCULATING PREFIX LENGTH.
  71. C   891214  Prologue converted to Version 4.0 format.  (WRB)
  72. C   900510  Added code to break messages between words.  (RWC)
  73. C***END PROLOGUE  XERPRN
  74.       CHARACTER*(*) PREFIX, MESSG
  75.       INTEGER NPREF, NWRAP
  76.       CHARACTER*148 CBUFF
  77.       INTEGER IU(5), NUNIT
  78.       CHARACTER*2 NEWLIN
  79.       PARAMETER (NEWLIN = '$$')
  80. C***FIRST EXECUTABLE STATEMENT  XERPRN
  81.       CALL XGETUA(IU,NUNIT)
  82. C
  83. C       A ZERO VALUE FOR A LOGICAL UNIT NUMBER MEANS TO USE THE STANDARD
  84. C       ERROR MESSAGE UNIT INSTEAD.  I1MACH(4) RETRIEVES THE STANDARD
  85. C       ERROR MESSAGE UNIT.
  86. C
  87.       N = I1MACH(4)
  88.       DO 10 I=1,NUNIT
  89.          IF (IU(I) .EQ. 0) IU(I) = N
  90.    10 CONTINUE
  91. C
  92. C       LPREF IS THE LENGTH OF THE PREFIX.  THE PREFIX IS PLACED AT THE
  93. C       BEGINNING OF CBUFF, THE CHARACTER BUFFER, AND KEPT THERE DURING
  94. C       THE REST OF THIS ROUTINE.
  95. C
  96.       IF ( NPREF .LT. 0 ) THEN
  97.          LPREF = LEN(PREFIX)
  98.       ELSE
  99.          LPREF = NPREF
  100.       ENDIF
  101.       LPREF = MIN(16, LPREF)
  102.       IF (LPREF .NE. 0) CBUFF(1:LPREF) = PREFIX
  103. C
  104. C       LWRAP IS THE MAXIMUM NUMBER OF CHARACTERS WE WANT TO TAKE AT ONE
  105. C       TIME FROM MESSG TO PRINT ON ONE LINE.
  106. C
  107.       LWRAP = MAX(16, MIN(132, NWRAP))
  108. C
  109. C       SET LENMSG TO THE LENGTH OF MESSG, IGNORE ANY TRAILING BLANKS.
  110. C
  111.       LENMSG = LEN(MESSG)
  112.       N = LENMSG
  113.       DO 20 I=1,N
  114.          IF (MESSG(LENMSG:LENMSG) .NE. ' ') GO TO 30
  115.          LENMSG = LENMSG - 1
  116.    20 CONTINUE
  117.    30 CONTINUE
  118. C
  119. C       IF THE MESSAGE IS ALL BLANKS, THEN PRINT ONE BLANK LINE.
  120. C
  121.       IF (LENMSG .EQ. 0) THEN
  122.          CBUFF(LPREF+1:LPREF+1) = ' '
  123.          DO 40 I=1,NUNIT
  124.             WRITE(IU(I), '(A)') CBUFF(1:LPREF+1)
  125.    40    CONTINUE
  126.          RETURN
  127.       ENDIF
  128. C
  129. C       SET NEXTC TO THE POSITION IN MESSG WHERE THE NEXT SUBSTRING
  130. C       STARTS.  FROM THIS POSITION WE SCAN FOR THE NEW LINE SENTINEL.
  131. C       WHEN NEXTC EXCEEDS LENMSG, THERE IS NO MORE TO PRINT.
  132. C       WE LOOP BACK TO LABEL 50 UNTIL ALL PIECES HAVE BEEN PRINTED.
  133. C
  134. C       WE LOOK FOR THE NEXT OCCURRENCE OF THE NEW LINE SENTINEL.  THE
  135. C       INDEX INTRINSIC FUNCTION RETURNS ZERO IF THERE IS NO OCCURRENCE
  136. C       OR IF THE LENGTH OF THE FIRST ARGUMENT IS LESS THAN THE LENGTH
  137. C       OF THE SECOND ARGUMENT.
  138. C
  139. C       THERE ARE SEVERAL CASES WHICH SHOULD BE CHECKED FOR IN THE
  140. C       FOLLOWING ORDER.  WE ARE ATTEMPTING TO SET LPIECE TO THE NUMBER
  141. C       OF CHARACTERS THAT SHOULD BE TAKEN FROM MESSG STARTING AT
  142. C       POSITION NEXTC.
  143. C
  144. C       LPIECE .EQ. 0   THE NEW LINE SENTINEL DOES NOT OCCUR IN THE
  145. C                       REMAINDER OF THE CHARACTER STRING.  LPIECE
  146. C                       SHOULD BE SET TO LWRAP OR LENMSG+1-NEXTC,
  147. C                       WHICHEVER IS LESS.
  148. C
  149. C       LPIECE .EQ. 1   THE NEW LINE SENTINEL STARTS AT MESSG(NEXTC:
  150. C                       NEXTC).  LPIECE IS EFFECTIVELY ZERO, AND WE
  151. C                       PRINT NOTHING TO AVOID PRODUCING UNNECESSARY
  152. C                       BLANK LINES.  THIS TAKES CARE OF THE SITUATION
  153. C                       WHERE THE LIBRARY ROUTINE HAS A MESSAGE OF
  154. C                       EXACTLY 72 CHARACTERS FOLLOWED BY A NEW LINE
  155. C                       SENTINEL FOLLOWED BY MORE CHARACTERS.  NEXTC
  156. C                       SHOULD BE INCREMENTED BY 2.
  157. C
  158. C       LPIECE .GT. LWRAP+1  REDUCE LPIECE TO LWRAP.
  159. C
  160. C       ELSE            THIS LAST CASE MEANS 2 .LE. LPIECE .LE. LWRAP+1
  161. C                       RESET LPIECE = LPIECE-1.  NOTE THAT THIS
  162. C                       PROPERLY HANDLES THE END CASE WHERE LPIECE .EQ.
  163. C                       LWRAP+1.  THAT IS, THE SENTINEL FALLS EXACTLY
  164. C                       AT THE END OF A LINE.
  165. C
  166.       NEXTC = 1
  167.    50 LPIECE = INDEX(MESSG(NEXTC:LENMSG), NEWLIN)
  168.       IF (LPIECE .EQ. 0) THEN
  169. C
  170. C       THERE WAS NO NEW LINE SENTINEL FOUND.
  171. C
  172.          IDELTA = 0
  173.          LPIECE = MIN(LWRAP, LENMSG+1-NEXTC)
  174.          IF (LPIECE .LT. LENMSG+1-NEXTC) THEN
  175.             DO 52 I=LPIECE+1,2,-1
  176.                IF (MESSG(NEXTC+I-1:NEXTC+I-1) .EQ. ' ') THEN
  177.                   LPIECE = I-1
  178.                   IDELTA = 1
  179.                   GOTO 54
  180.                ENDIF
  181.    52       CONTINUE
  182.          ENDIF
  183.    54    CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1)
  184.          NEXTC = NEXTC + LPIECE + IDELTA
  185.       ELSEIF (LPIECE .EQ. 1) THEN
  186. C
  187. C       WE HAVE A NEW LINE SENTINEL AT MESSG(NEXTC:NEXTC+1).
  188. C       DON'T PRINT A BLANK LINE.
  189. C
  190.          NEXTC = NEXTC + 2
  191.          GO TO 50
  192.       ELSEIF (LPIECE .GT. LWRAP+1) THEN
  193. C
  194. C       LPIECE SHOULD BE SET DOWN TO LWRAP.
  195. C
  196.          IDELTA = 0
  197.          LPIECE = LWRAP
  198.          DO 56 I=LPIECE+1,2,-1
  199.             IF (MESSG(NEXTC+I-1:NEXTC+I-1) .EQ. ' ') THEN
  200.                LPIECE = I-1
  201.                IDELTA = 1
  202.                GOTO 58
  203.             ENDIF
  204.    56    CONTINUE
  205.    58    CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1)
  206.          NEXTC = NEXTC + LPIECE + IDELTA
  207.       ELSE
  208. C
  209. C       IF WE ARRIVE HERE, IT MEANS 2 .LE. LPIECE .LE. LWRAP+1.
  210. C       WE SHOULD DECREMENT LPIECE BY ONE.
  211. C
  212.          LPIECE = LPIECE - 1
  213.          CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1)
  214.          NEXTC  = NEXTC + LPIECE + 2
  215.       ENDIF
  216. C
  217. C       PRINT
  218. C
  219.       DO 60 I=1,NUNIT
  220.          WRITE(IU(I), '(A)') CBUFF(1:LPREF+LPIECE)
  221.    60 CONTINUE
  222. C
  223.       IF (NEXTC .LE. LENMSG) GO TO 50
  224.       RETURN
  225.       END
  226.